COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	These routines were written by Lyle Ramshaw in fall, 1980
C00003 00003	Routines for Dover-style .oc files
C00014 00004	Routines for presswd mode.
C00020 ENDMK
C⊗;
comment These routines were written by Lyle Ramshaw in fall, 1980;
comment Routines for Dover-style .oc files;

comment In this mode, we output characters as Orbitized PARC-style
.AC files with a rotation of 0 minutes.  This demands both changing to
32 bitsperword from 36, and also rotating the raster 90 degrees, because
the conventions of .AC format dictate that a non-rotated character is
scanned from bottom-to-top, left-to-right (as Dover's scan);

saf integer array BBoxArray,BBoyArray,BBdxArray,BBdyArray[0:'177];
integer bbox,bboy,bbdx,bbdy,bbxl,bbxr,bbyl,bbyh # dimensions of the
	character bounding box, set by bndbox;
boolean emptychar # true iff char has empty raster, set by bndbox;
define bitloc(x)=⊂((x+(1000*bitsperwd+hw-1))mod bitsperwd)⊃ # number of
	bits to the left of bit x, copied from mfrast;
boolean bndboxvalid # true iff bndbox has been called for this character;

procedure bndbox;
comment this procedure computes the bounding box of the character in 
	pixel coordinates, since both .oc and .wd format demand it.  Leaves
	coordinates of bounding box in bb** global integers---returns
	true iff the raster is non-blank;
begin integer i,xw,y,z,xl,xr,lz,lzr,xlb,xrb,yl,yh;
label nonblank3,nonblank4;
xl←xleft; xr←xright; z←0;
loop	begin comment try to eliminate blank column at left;
	xw←xl*rspan;
	for y←xw+ylow thru xw+yhigh do z←z lor rast[y];
	if z then done;
	xl←xl+1;
	if xl>xr then
		begin comment blank raster;
		bbdx←bbdy←bbox←bboy←0;
		bbxl←0; bbxr←-1; bbyl←0; bbyh←-1 # as good as any other;
		emptychar←true; bndboxvalid←true;
		return;
		end;
	end;
lz←0; while z>0 do
	begin lz←lz+1; z←z lsh 1;
	end;
xlb←(1-hw-bitsperwd*rcol(0))+lz+bitsperwd*xl;
z←0;
loop	begin comment try to eliminate blank column at right.  The
		loop is guaranteed to halt, since raster is non-empty;
	xw←xr*rspan;
	for y←xw+ylow thru xw+yhigh do z←z lor rast[y];
	if z then done;
	xr←xr-1;
	end;
comment Assert z≠0;
lzr←rightmostbitindex(z);
xrb←(1-hw-bitsperwd*rcol(0))+lzr+bitsperwd*xr;
yl←ylow; yh←yhigh;
loop	begin comment try to eliminate blank row at bottom;
	for xw←xl*rspan+yl step rspan until xr*rspan+yl do
		if rast[xw] then go to nonblank3;
	yl←yl+1;
	end;
nonblank3:
loop	begin comment try to eliminate blank row at top;
	for xw←xl*rspan+yh step rspan until xr*rspan+yh do
		if rast[xw] then go to nonblank4;
	yh←yh-1;
	end;
nonblank4:
bbxl←xlb; bbxr←xrb; bbyl←yl; bbyh←yh;
bbdx←xrb-xlb+1; bbdy←yh-yl+1; bbox←xlb; bboy←yl;
emptychar←false; bndboxvalid←true;
end;

procedure makeoc # outputs the current character to .oc file;
begin integer i,x,y,ch;
integer padbits, charbits, charwords;
integer coladdr, wdaddr, shft, bitptr, pfield, accum, ocfilepos;
ch←openofil(doveroc);
if not bndboxvalid then bndbox;
if charsegptr[charcode]≠-1 then error("Duplicate charcode: '"&cvos(charcode));
BBdxArray[charcode]←bbdx; BBdyArray[charcode]←bbdy;
BBoxArray[charcode]←bbox; BBoyArray[charcode]←bboy;
if not vectorwidths then
	begin
	charwx←charwd;
	charwy←0.0;
	end;
CharWidthX[charcode]←charwx;
CharWidthY[charcode]←charwy;
charbits←bbdx*bbdy;
charwords←2*((charbits+31) div 32) # orbitchars block must be
	and even number of sixteen-bit words;
padbits←16*charwords-charbits;
charsegptr[charcode]←bytecount[doveroc] div 2 # bytes to 16-bit words;

comment Send the character segment out to the file:;
Wout(doveroc,-bbdy);
Wout(doveroc,bbdx-1);
accum←0; bitptr←point(1,accum,-1);
pfield←point(6,bitptr,5) # points at the "P" field of bitptr;
for x←bbxl thru bbxr do
	begin "move one column"
	coladdr←rcol(x)*rspan;
	shft←(bitloc(x)-35);
	for wdaddr←coladdr+bbyl thru coladdr+bbyh do
		begin "move one bit"
		idpb(rast[wdaddr] lsh shft,bitptr);
		if ldb(pfield)=4 then 
			begin
			dpb(36,pfield) # reset bitptr to left end of accum;
			DoutAligned(doveroc,accum);
			end;
		end "move one bit";
	end "move one column";
for i←1 thru padbits do idpb(0,bitptr);
if ldb(pfield)=4 then 
	begin
	dpb(36,pfield) # reset bitptr to left end of accum;
	DoutAligned(doveroc,accum);
	end;
if ldb(pfield)≠36 then confusion;
end;


procedure occloseout;
begin
integer i,c,bc,ec,nc; integer fontsegstart, fontsegend, relptrbase;
integer ch # channel for output;
ch←ochan[doveroc];
for bc←0 step 1 until '177 do if charsegptr[bc]≠-1 then done;
for ec←'177 step -1 until 0 do if charsegptr[ec]≠-1 then done;
if bc>ec then
	begin
	bc←1; ec←0;
	error("No characters in this font");
	end;
nc←ec-bc+1;
if fontfacebyte<0 or fontfacebyte>255 then
	error("Fontfacebyte out of bounds");
while rotation>360 do rotation←rotation-360;
while rotation<0 do rotation←rotation+360;
fontsegstart←charsegfilepos-(8+2)*nc;
fontsegend←bytecount[doveroc] div 2;
useto(ch,1) # reset file position to beginning;
bytecount[doveroc]←0;
Wout(doveroc,IX(1,12)) # header for family-name IX;
Wout(doveroc,0) # name code;
BCPLout(doveroc,fontidentifier,20);
Wout(doveroc,IX(5,11)) # header for orbit-chars IX;
Bout(doveroc,0) # name code again;
Bout(doveroc,fontfacebyte) # logical size encoded as face byte;
Bout(doveroc,bc); Bout(doveroc,ec);
define ppi=⊂72.27⊃ # points per inch according to TEX/Metafont;
Wout(doveroc,(designsize*magnification*2540/ppi)+0.5) # physical siz in micas;
Wout(doveroc,(60*rotation)+0.5) # rotation in minutes of arc;
Dout(doveroc,fontsegstart) # starting file pos of font segment;
Dout(doveroc,fontsegend-fontsegstart) # and font segment length;
Wout(doveroc,(xresolution*ppi*10/magnification)+0.5) # X resolution in
		units of pixels/(10 inches);
Wout(doveroc,(yresolution*ppi*10/magnification)+0.5) # Y resolution in
		units of pixels/(10 inches);
Wout(doveroc,IX(0,1)) # endIX;
comment next, write the char width table and char segment ptrs--first
	get to the correct place in the file;
DEBUGONLY if bytecount[doveroc]≠2*('30) then confusion;
for i←1 thru (fontsegstart-'30) div 2 do DoutAligned(doveroc,0);
for c←bc thru ec do
	if charsegptr[c]≠-1 then
		begin
		comment Convert the spacing Xwidth of the character
		  from points into (fixed.fraction) pixels;
		integer newwidth;
		newwidth←(CharWidthX[c]*xresolution*(2↑16))+0.5;
		Dout(doveroc,newwidth);
		newwidth←(CharWidthY[c]*yresolution*(2↑16))+0.5;
		Dout(doveroc,newwidth);
		Wout(doveroc,BBoxArray[c]);
		Wout(doveroc,BBoyArray[c]);
		Wout(doveroc,BBdxArray[c]);
		Wout(doveroc,BBdyArray[c]);
		end
	  else	begin
		integer i;
		for i←1 thru 7 do Wout(doveroc,0);
		Wout(doveroc,-1) # marks a non-existent character;
		end;
relptrbase←charsegfilepos-2*nc;
DEBUGONLY if bytecount[doveroc]≠relptrbase*2 then confusion;
for c←bc thru ec do
	if charsegptr[c]≠-1 then Dout(doveroc,charsegptr[c]-relptrbase)
		else Dout(doveroc,-1);
end;


comment Routines for presswd mode.;

procedure makewd # stores the width of current character away for .wd file;
begin
integer ch;
ch←openofil(presswd);
if not bndboxvalid then bndbox;
comment the following couple of statements also appear in makeoc, but
	repeating them is OK;
if not vectorwidths then
	begin
	charwx←charwd;
	charwy←0.0;
	end;
CharWidthX[charcode]←charwx;
CharWidthY[charcode]←charwy # end of repetition;
if charwx<charwxmin then charwxmin←charwx;
if charwx>charwxmax then charwxmax←charwx;
if charwy<charwymin then charwymin←charwy;
if charwy>charwymax then charwymax←charwy;
if not emptychar then
	begin comment update font bounding box;
	if bbxl<bbxlmin then bbxlmin←bbxl;
	if bbxr>bbxrmax then bbxrmax←bbxr;
	if bbyl<bbylmin then bbylmin←bbyl;
	if bbyh>bbyhmax then bbyhmax←bbyh;
	end;
end;

procedure wdcloseout;
begin
integer c,bc,ec,nc;
boolean fixedx, fixedy;
integer wdlen # length of data segment in 16-bit words;
real fbbox, fbboy, fbbdx, fbbdy # font bounding box metrics in points;
  procedure RealWout(real r) # scale and output one numeric value;
	begin integer int;
	int←((r*1000/designsize) + 0.5);
	if abs(int)≥(2↑15-1) then
	 error("Distance of "&cvf(r)&" points exceeds bounds of .WD format.");
	Wout(presswd,int);
	end;

for bc←0 step 1 until '177 do if CharWidthX[bc]≠nonexistentcharflag then done;
for ec←'177 step -1 until 0 do if CharWidthX[ec]≠nonexistentcharflag then done;
if bc>ec then
	begin
	bc←1; ec←0;
	error("No characters in this font");
	end;
nc←ec-bc+1;

if fontfacebyte<0 or fontfacebyte>255 then
	error("Font face byte out of bounds");
while rotation>360 do rotation←rotation-360;
while rotation<0 do rotation←rotation+360;

if charwxmax=charwxmin then fixedx←true else fixedx←false;
if charwymax=charwymin then fixedy←true else fixedy←false;
wdlen←5  comment for header;
	+(if fixedx then 1 else nc) comment for x-widths;
	+(if fixedy then 1 else nc); comment for y-widths;

if bbxlmin>bbxrmax then 
	comment font is entirely empty characters!;
	fbbox←fbboy←fbbdx←fbbdy←0.0
   else
	begin
	fbbox←bbxlmin/xresolution;
	fbboy←bbylmin/yresolution;
	fbbdx←(bbxrmax-bbxlmin+1)/xresolution;
	fbbdy←(bbyhmax-bbylmin+1)/yresolution;
	end;

Wout(presswd,IX(1,12)) # header for family-name IX;
Wout(presswd,0) # name code;
BCPLout(presswd,fontidentifier,20);
Wout(presswd,IX(4,9)) # header for orbit-chars IX;
Bout(presswd,0) # name code again;
Bout(presswd,fontfacebyte) # logical size encoded as face byte;
Bout(presswd,bc); Bout(presswd,ec);
Wout(presswd,0) # physical size field: 0 means scalable;
Wout(presswd,(60*rotation)+0.5) # rotation in minutes of arc;
Dout(presswd,22) # starting file pos of font segment (right after endIX);
Dout(presswd,wdlen) # length of data segment;
Wout(presswd,IX(0,1)) # endIX;

comment output the width table;
RealWout(fbbox) # X offset of font bounding box;
RealWout(fbboy) # Y offset of font bounding box;
RealWout(fbbdx) # X dimension of font bounding box;
RealWout(fbbdy) # Y dimension of font bounding box;
Wout(presswd,(if fixedx then 1 lsh 15 else 0)+
	(if fixedy then 1 lsh 14 else 0)) # fixedflags;
if fixedx then RealWout(charwxmax) 
 else for c←bc thru ec do
	if CharWidthX[c]=nonexistentcharflag then
		Wout(presswd,1 lsh 15)
	else RealWout(CharWidthX[c]);
if fixedy then RealWout(charwymax) 
 else for c←bc thru ec do
	if CharWidthX[c]=nonexistentcharflag then
		Wout(presswd,1 lsh 15)
	else RealWout(CharWidthY[c]);
if (bytecount[presswd] mod 4)≠0 then
	Wout(presswd, 0) # pad to 32-bit-word boundary, so that byte-output
		routines will flush their buffers and get the data to disk;
end;